home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Icon 8.1 / msm-1 / common.sit / rtdb.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-09-19  |  47.2 KB  |  1,699 lines  |  [TEXT/MPS ]
  1. /*
  2.  * Routines to read a data base of run-time information.
  3.  */
  4. #include <ctype.h>
  5. #include "::h:gsupport.h"
  6. #include "::h:version.h"
  7. #include "icontype.h"
  8.  
  9. /*
  10.  * GetInt - the next thing in the data base is an integer. Get it.
  11.  */
  12. #define GetInt(n, c)\
  13.    n = 0;\
  14.    while (isdigit(c)) {\
  15.       n = n * 10 + (c - '0');\
  16.       c = getc(db);\
  17.       }
  18.  
  19. /*
  20.  * SkipWhSp - skip white space characters in the data base.
  21.  */
  22. #define SkipWhSp(c)\
  23.    while (isspace(c)) {\
  24.       if (c == '\n')\
  25.          ++dbline;\
  26.       c = getc(db);\
  27.       }
  28.  
  29. /*
  30.  * prototypes for static functions.
  31.  */
  32. hidden int            cmp_1_pre  Params((int p1, int p2));
  33. hidden struct il_code *db_abstr  Params((noargs));
  34. hidden novalue         db_case   Params((struct il_code *il, int num_cases));
  35. hidden novalue         db_err3   Params((int fatal,char *s1,char *s2,char *s3));
  36. hidden int             db_icntyp Params((noargs));
  37. hidden struct il_c    *db_ilc    Params((noargs));
  38. hidden struct il_c    *db_ilcret Params((int il_c_type));
  39. hidden struct il_code *db_inlin  Params((noargs));
  40. hidden struct il_code *db_ilvar  Params((noargs));
  41. hidden int             db_rtflg  Params((noargs));
  42. hidden int             db_tndtyp Params((noargs));
  43. hidden struct il_c    *new_ilc   Params((int il_c_type));
  44. hidden novalue          quoted   Params((int delim));
  45.  
  46. extern char *progname;   /* name of program using this module */
  47.  
  48. static char *dbname;           /* data base name */
  49. static FILE *db;               /* data base  file */
  50. static int dbline;             /* line number current position in data base */
  51. static struct str_buf db_sbuf; /* string buffer */
  52. static int *type_map;          /* map data base type codes to internal ones */
  53. static int *compnt_map;        /* map data base component codes to internal */
  54.  
  55. /*
  56.  * opendb - open data base and do other house keeping.
  57.  */
  58. int db_open(s, lrgintflg)
  59. char *s;
  60. char **lrgintflg;
  61.    {
  62.    char *msg_buf;
  63.    char *id;
  64.    int i, n;
  65.    register int c;
  66.    static int first_time = 1;
  67.  
  68.    if (first_time) {
  69.       first_time = 0;
  70.       init_sbuf(&db_sbuf);
  71.       }
  72.    dbname = s;  
  73.    dbline = 0;
  74.    *lrgintflg = NULL;
  75.    db = fopen(dbname, "r");
  76.    if (db == NULL)
  77.       return 0;
  78.    ++dbline;
  79.  
  80.    /*
  81.     * Make sure the version number in the data base is what is expected.
  82.     */
  83.    s = db_string();
  84.    if (strcmp(s, DVersion) != 0) {
  85.       msg_buf = (char *)alloc((unsigned int) 35 + (int)(strlen(s) +
  86.          strlen(progname) + strlen(DVersion)));
  87.       sprintf(msg_buf, "found version %s, %s requires version %s",
  88.            s, progname, DVersion);
  89.       db_err1(1, msg_buf);
  90.       }
  91.  
  92.    *lrgintflg = db_string();  /* large integer flag */
  93.  
  94.    /*
  95.     * Create tables for mapping type codes and type component codes in
  96.     *  the data base to those compiled into this program. The codes may
  97.     *  be different if types have been added to the program since the
  98.     *  data base was created.
  99.     */
  100.    type_map = (int *)alloc((unsigned int)(num_typs * sizeof(int)));
  101.    db_chstr("", "types");   /* verify section header */
  102.    c = getc(db);
  103.    SkipWhSp(c)
  104.    while (c == 'T') {
  105.       c = getc(db);
  106.       if (!isdigit(c))
  107.          db_err1(1, "expected type code");
  108.       GetInt(n, c)
  109.       if (n >= num_typs)
  110.          db_err1(1, "data base inconsistant with program, rebuild data base");
  111.       SkipWhSp(c)
  112.       if (c != ':')
  113.          db_err1(1, "expected ':'");
  114.       id = db_string();
  115.       for (i = 0; strcmp(id, icontypes[i].id) != 0; ++i)
  116.          if (i >= num_typs)
  117.             db_err2(1, "unknown type:", id);
  118.       type_map[n] = i;
  119.       c = getc(db);
  120.       SkipWhSp(c)
  121.       }
  122.    db_chstr("", "endsect");
  123.  
  124.    compnt_map = (int *)alloc((unsigned int)(num_cmpnts * sizeof(int)));
  125.    db_chstr("", "components");   /* verify section header */
  126.    c = getc(db);
  127.    SkipWhSp(c)
  128.    while (c == 'C') {
  129.       c = getc(db);
  130.       if (!isdigit(c))
  131.          db_err1(1, "expected type component code");
  132.       GetInt(n, c)
  133.       if (n >= num_cmpnts)
  134.          db_err1(1, "data base inconsistant with program, rebuild data base");
  135.       SkipWhSp(c)
  136.       if (c != ':')
  137.          db_err1(1, "expected ':'");
  138.       id = db_string();
  139.       for (i = 0; strcmp(id, typecompnt[i].id) != 0; ++i)
  140.          if (i >= num_cmpnts)
  141.             db_err2(1, "unknown type compontent:", id);
  142.       compnt_map[n] = i;
  143.       c = getc(db);
  144.       SkipWhSp(c)
  145.       }
  146.    db_chstr("", "endsect");
  147.  
  148.    return 1;
  149.    }
  150.  
  151. /*
  152.  * db_close - close data base.
  153.  */
  154. novalue db_close()
  155.    {
  156.    if (fclose(db) != 0)
  157.       db_err2(0, "cannot close", dbname);
  158.    }
  159.  
  160. /*
  161.  * db_string - get a white-space delimited string from the data base.
  162.  */
  163. char *db_string()
  164.    {
  165.    register int c;
  166.  
  167.    /*
  168.     * Look for the start of the string; '$' starts a special indicator.
  169.     *  Copy characters into string buffer until white space is found.
  170.     */
  171.    c = getc(db);
  172.    SkipWhSp(c);
  173.    if (c == EOF)
  174.       db_err1(1, "unexpected EOF");
  175.    if (c == '$')
  176.       return NULL;
  177.    while (!isspace(c) && c != EOF) {
  178.       AppChar(db_sbuf, c);
  179.       c = getc(db);
  180.       }
  181.    if (c == '\n')
  182.       ++dbline;
  183.    return str_install(&db_sbuf); /* put string in string table */
  184.    }
  185.  
  186. /*
  187.  * db_impl - read basic header information for an operation into a structure
  188.  *   and return it.
  189.  */
  190. struct implement *db_impl(oper_typ)
  191. int oper_typ;
  192.    {
  193.    register struct implement *ip;
  194.    register int c;
  195.    int i;
  196.    char *name;
  197.    long n;
  198.  
  199.    /*
  200.     * Get operation name.
  201.     */
  202.    if ((name = db_string()) == NULL)
  203.       return NULL;
  204.  
  205.    /*
  206.     * Create an internal structure to hold the data base entry.
  207.     */
  208.    ip = NewStruct(implement);
  209.    ip->blink = NULL;
  210.    ip->iconc_flgs = 0;         /* reserved for internal use by compiler */
  211.    ip->oper_typ = oper_typ;
  212.    ip->name = name;
  213.    ip->op = NULL;
  214.  
  215.    /*
  216.     * Get the function name prefix assigned to this operation.
  217.     */
  218.    c = getc(db);
  219.    SkipWhSp(c)
  220.    if (isalpha(c) || isdigit(c))
  221.       ip->prefix[0] = c;
  222.    else
  223.      db_err2(1, "invalid prefix for", ip->name);
  224.    c = getc(db);
  225.    if (isalpha(c) || isdigit(c))
  226.       ip->prefix[1] = c;
  227.    else
  228.      db_err2(1, "invalid prefix for", ip->name);
  229.  
  230.    /*
  231.     * Get the number of parameters.
  232.     */
  233.    c = getc(db);
  234.    SkipWhSp(c)
  235.    if (!isdigit(c))
  236.      db_err2(1, "number of parameters missing for", ip->name);
  237.    GetInt(n, c)
  238.    ip->nargs = n;
  239.  
  240.    /*
  241.     * Get the flags that indicate whether each parameter requires a dereferenced
  242.     *  and/or undereferenced value, and whether the last parameter represents
  243.     *  the end of a varargs list. Store the flags in an array.
  244.     */
  245.    if (n == 0)
  246.       ip->arg_flgs = NULL;
  247.    else
  248.       ip->arg_flgs = (int *)alloc((unsigned int) (sizeof(int) * n));
  249.    if (c != '(')
  250.       db_err2(1, "parameter flags missing for", ip->name);
  251.    c = getc(db);
  252.    for (i = 0; i < n; ++i) {
  253.       if (c == ',' || c == ')')
  254.          db_err2(1, "parameter flag missing for", ip->name);
  255.       ip->arg_flgs[i] = 0;
  256.       while (c != ',' && c != ')') {
  257.           switch (c) {
  258.              case 'u':
  259.                 ip->arg_flgs[i] |= RtParm;
  260.                 break;
  261.              case 'd':
  262.                 ip->arg_flgs[i] |= DrfPrm;
  263.                 break;
  264.              case 'v':
  265.                 ip->arg_flgs[i] |= VarPrm;
  266.                 break;
  267.              default:
  268.                 db_err2(1, "invalid parameter flag for", ip->name);
  269.              }
  270.          c = getc(db);
  271.          }
  272.       if (c == ',')
  273.          c = getc(db);
  274.       }
  275.    if (c != ')')
  276.      db_err2(1, "invalid parameter flag list for", ip->name);
  277.  
  278.    /*
  279.     * Get the result sequence indicator for the operation.
  280.     */
  281.    c = getc(db);
  282.    SkipWhSp(c)
  283.    if (c != '{')
  284.      db_err2(1, "result sequence missing for", ip->name);
  285.    c = getc(db);
  286.    ip->resume = 0;
  287.    if (c == '}') {
  288.       ip->min_result = NoRsltSeq;
  289.       ip->max_result = NoRsltSeq;
  290.       }
  291.    else {
  292.       if (!isdigit(c))
  293.         db_err2(1, "invalid result sequence for", ip->name);
  294.       GetInt(n, c)
  295.       ip->min_result = n;
  296.       if (c != ',')
  297.         db_err2(1, "invalid result sequence for", ip->name);
  298.       c = getc(db);
  299.       if (c == '*') {
  300.          ip->max_result = UnbndSeq;
  301.          c = getc(db);
  302.          }
  303.       else if (isdigit(c)) {
  304.          GetInt(n, c)
  305.          ip->max_result = n;
  306.          }
  307.       else
  308.         db_err2(1, "invalid result sequence for", ip->name);
  309.       if (c == '+') {
  310.          ip->resume = 1;
  311.          c = getc(db);
  312.          }
  313.       if (c != '}')
  314.         db_err2(1, "invalid result sequence for", ip->name);
  315.       }
  316.  
  317.    /*
  318.     * Get the flag indicating whether the operation contains returns, fails,
  319.     *  or suspends.
  320.     */
  321.    ip->ret_flag = db_rtflg();
  322.  
  323.    /*
  324.     * Get the t/f flag that indicates whether the operation explicitly
  325.     *  uses the 'result' location.
  326.     */
  327.    c = getc(db);
  328.    SkipWhSp(c)
  329.    switch (c) {
  330.       case 't':
  331.          ip->use_rslt = 1;
  332.          break;
  333.       case 'f':
  334.          ip->use_rslt = 0;
  335.          break;
  336.       default:
  337.          db_err2(1, "invalid 'result' use indicator for", ip->name);
  338.          }
  339.    return ip;
  340.    }
  341.  
  342. /*
  343.  * db_code - read the RTL code for the body of an operation.
  344.  */
  345. novalue db_code(ip)
  346. struct implement *ip;
  347.    {
  348.    register int c;
  349.    char *s;
  350.    word n;
  351.    int var_type;
  352.    int i;
  353.  
  354.    /*
  355.     * read the descriptive string.
  356.     */
  357.    c = getc(db);
  358.    SkipWhSp(c)
  359.    if (c != '"')
  360.       db_err1(1, "operation description expected");
  361.    for (c = getc(db); c != '"' && c != '\n' && c != EOF; c = getc(db)) {
  362.       if (c == '\\') {
  363.          AppChar(db_sbuf, c);
  364.          c = getc(db);
  365.          }
  366.       AppChar(db_sbuf, c);
  367.       }
  368.    if (c != '"')
  369.       db_err1(1, "expected '\"'");
  370.    ip->comment = str_install(&db_sbuf);
  371.  
  372.    /*
  373.     * Get the number of tended variables in the declare clause.
  374.     */
  375.    c = getc(db);
  376.    SkipWhSp(c)
  377.    GetInt(n, c)
  378.    ip->ntnds = n;
  379.  
  380.    /*
  381.     * Read information about the tended variables into an array.
  382.     */
  383.    if (n == 0)
  384.       ip->tnds = NULL;
  385.    else
  386.       ip->tnds = (struct tend_var *)alloc((unsigned int)
  387.          (sizeof(struct tend_var) * n));
  388.    for (i = 0; i < n; ++i) {
  389.       var_type = db_tndtyp();  /* type of tended declaration */
  390.       ip->tnds[i].var_type = var_type;
  391.       ip->tnds[i].blk_name = NULL;
  392.       if (var_type == TndBlk) {
  393.          /*
  394.           * Tended block pointer declarations include a block type or '*' to
  395.           *  indicate 'union block *'.
  396.           */
  397.          s = db_string();
  398.          if (s == NULL)
  399.             db_err1(1, "block name expected");
  400.          if (*s != '*')
  401.             ip->tnds[i].blk_name = s;
  402.          }
  403.       ip->tnds[i].init = db_ilc();  /* C code for declaration initializer */
  404.       }
  405.  
  406.    /*
  407.     * Get the number of non-tended variables in the declare clause.
  408.     */
  409.    c = getc(db);
  410.    SkipWhSp(c)
  411.    GetInt(n, c)
  412.    ip->nvars = n;
  413.  
  414.    /*
  415.     * Get each non-tended declaration and store it in an array.
  416.     */
  417.    if (n == 0)
  418.       ip->vars = NULL;
  419.    else
  420.       ip->vars = (struct ord_var *)alloc((unsigned int)
  421.          (sizeof(struct ord_var) * n));
  422.    for (i = 0; i < n; ++i) {
  423.       s = db_string();             /* variable name */
  424.       if (s == NULL)
  425.          db_err1(1, "variable name expected");
  426.       ip->vars[i].name = s;
  427.       ip->vars[i].dcl = db_ilc();  /* full declaration including name */
  428.       }
  429.  
  430.    /*
  431.     * Get the executable RTL code.
  432.     */
  433.    ip->in_line = db_inlin();
  434.  
  435.    /*
  436.     * We should be at the end of the operation.
  437.     */
  438.    c = getc(db);
  439.    SkipWhSp(c)
  440.    if (c != '$')
  441.       db_err1(1, "expected $end");
  442.    }
  443.  
  444. /*
  445.  * db_inlin - read in the in-line code (executable RTL code) for an operation.
  446.  */
  447. static struct il_code *db_inlin()
  448.    {
  449.    struct il_code *il;
  450.    register int c;
  451.    int i;
  452.    int indx;
  453.    int fall_thru;
  454.    int n, n1;
  455.  
  456.    /*
  457.     * The following nested switch statements act as a trie for recognizing
  458.     *  the prefix form of RTL code in the data base.
  459.     */
  460.    c = getc(db);
  461.    SkipWhSp(c)
  462.    switch (c) {
  463.       case 'a':
  464.          switch (getc(db)) {
  465.             case 'b': {
  466.                db_chstr("ab", "str");
  467.                il = new_il(IL_Abstr, 2);        /* abstract type computation */
  468.                il->u[0].fld = db_abstr();       /* side effects */
  469.                il->u[1].fld = db_abstr();       /* return type */
  470.                break;
  471.                }
  472.             case 'c': {
  473.                db_chstr("ac", "ase");
  474.                il = new_il(IL_Acase, 5);        /* arith_case */
  475.                il->u[0].fld = db_ilvar();       /* first variable */
  476.                il->u[1].fld = db_ilvar();       /* second variable */
  477.                il->u[2].fld = db_inlin();       /* C_integer action */
  478.                il->u[3].fld = db_inlin();       /* integer action */
  479.                il->u[4].fld = db_inlin();       /* C_double action */
  480.                break;
  481.                }
  482.             default:
  483.                db_err1(1, "expected abstr or acase");
  484.             }
  485.          break;
  486.  
  487.       case 'b':
  488.          db_chstr("b", "lock");
  489.          c = getc(db);
  490.          SkipWhSp(c)
  491.          if (c == 't')
  492.             fall_thru = 1;
  493.          else
  494.             fall_thru = 0;
  495.          c = getc(db);
  496.          SkipWhSp(c)
  497.          GetInt(n, c)
  498.          il = new_il(IL_Block, 3 + n);    /* block of in-line C code */
  499.          il->u[0].n = fall_thru;
  500.          il->u[1].n = n;                  /* number of local tended */
  501.          for (i = 2; i - 2 < n; ++i)
  502.              il->u[i].n = db_tndtyp();    /* tended declaration */
  503.          il->u[i].c_cd = db_ilc();        /* C code */
  504.          break;
  505.  
  506.       case 'c':
  507.          switch (getc(db)) {
  508.             case 'a': {
  509.                char prfx3;
  510.                int ret_val;
  511.                int ret_flag;
  512.                int rslt;
  513.                int num_sbuf;
  514.                int num_cbuf;
  515.  
  516.                db_chstr("ca", "ll");
  517.                /*
  518.                 * Call to body function. Get the letter used as the 3rd
  519.                 *  character of the function prefix.
  520.                 */
  521.                c = getc(db);
  522.                SkipWhSp(c)
  523.                prfx3 = c;
  524.  
  525.                /*
  526.                 * Determine what the body function returns directly.
  527.                 */
  528.                c = getc(db);
  529.                SkipWhSp(c)
  530.                switch (c) {
  531.                   case 'i':
  532.                      ret_val = RetInt;    /* returns C integer */
  533.                      break;
  534.                   case 'd':
  535.                      ret_val = RetDbl;    /* returns C double */
  536.                      break;
  537.                   case 'n':
  538.                      ret_val = RetNoVal;  /* returns nothing directly */
  539.                      break;
  540.                   case 's':
  541.                      ret_val = RetSig;    /* returns a signal */
  542.                      break;
  543.                   default:
  544.                      db_err1(1, "invalid indicator for type of return value");
  545.                   }
  546.  
  547.               /*
  548.                * Get the return/suspend/fail/fall-through flag.
  549.                */
  550.                c = getc(db);
  551.                ret_flag = db_rtflg();
  552.  
  553.                /*
  554.                 * Get the flag indicating whether the body function expects
  555.                 *  to have an explicit result location passed to it.
  556.                 */
  557.                c = getc(db);
  558.                SkipWhSp(c)
  559.                switch (c) {
  560.                   case 't':
  561.                      rslt = 1;
  562.                      break;
  563.                   case 'f':
  564.                      rslt = 0;
  565.                      break;
  566.                   default:
  567.                      db_err1(1, "t or f expected");
  568.                   }
  569.  
  570.                c = getc(db);
  571.                SkipWhSp(c)
  572.                GetInt(num_sbuf, c)  /* number of cset buffers */
  573.                c = getc(db);
  574.                SkipWhSp(c)
  575.                GetInt(num_cbuf, c)  /* number of string buffers */
  576.                c = getc(db);
  577.                SkipWhSp(c)
  578.                GetInt(n, c)         /* num args */
  579.  
  580.                il = new_il(IL_Call, 8 + n * 2);
  581.                il->u[0].n = 0;      /* reserved for internal use by compiler */
  582.                il->u[1].n = prfx3;
  583.                il->u[2].n = ret_val;
  584.                il->u[3].n = ret_flag;
  585.                il->u[4].n = rslt;
  586.                il->u[5].n = num_sbuf;
  587.                il->u[6].n = num_cbuf;
  588.                il->u[7].n = n;
  589.                indx = 8;
  590.  
  591.                /*
  592.                 * get the prototype parameter declarations and actual arguments.
  593.                 */
  594.                n *= 2;
  595.                while (n--)
  596.                   il->u[indx++].c_cd = db_ilc();
  597.                }
  598.                break;
  599.  
  600.             case 'n':
  601.                if (getc(db) != 'v')
  602.                   db_err1(1, "expected cnv1 or cnv2");
  603.                switch (getc(db)) {
  604.                   case '1':
  605.                      il = new_il(IL_Cnv1, 2);
  606.                      il->u[0].n = db_icntyp();      /* type code */
  607.                      il->u[1].fld = db_ilvar();     /* source */
  608.                      break;
  609.                   case '2':
  610.                      il = new_il(IL_Cnv2, 3);
  611.                      il->u[0].n = db_icntyp();      /* type code */
  612.                      il->u[1].fld = db_ilvar();     /* source */
  613.                      il->u[2].c_cd = db_ilc();      /* destination */
  614.                      break;
  615.                   default:
  616.                      db_err1(1, "expected cnv1 or cnv2");
  617.                   }
  618.                break;
  619.  
  620.             case 'o':
  621.                db_chstr("co", "nst");
  622.                il = new_il(IL_Const, 2);     /* constant keyword */
  623.                il->u[0].n = db_icntyp();     /* type code */
  624.                c = getc(db);
  625.                SkipWhSp(c)
  626.                if (c == '"' || c == '\'') {
  627.                   quoted(c);
  628.                   c = getc(db);              /* quoted literal without quotes */
  629.                   }
  630.                else
  631.                   while (c != EOF && !isspace(c)) {
  632.                      AppChar(db_sbuf, c);
  633.                      c = getc(db);
  634.                      }
  635.                il->u[1].s = str_install(&db_sbuf); /* non-quoted values */
  636.                break;
  637.  
  638.             default:
  639.                db_err1(1, "expected call, const, cnv1, or cnv2");
  640.             }
  641.          break;
  642.  
  643.       case 'd':
  644.          if (getc(db) != 'e' || getc(db) != 'f')
  645.             db_err1(1, "expected def1 or def2");
  646.          switch (getc(db)) {
  647.             case '1':
  648.                il = new_il(IL_Def1, 3);       /* defaulting, no dest. field */
  649.                il->u[0].n = db_icntyp();      /* type code */
  650.                il->u[1].fld = db_ilvar();     /* source */
  651.                il->u[2].c_cd = db_ilc();      /* default value */
  652.                break;
  653.             case '2':
  654.                il = new_il(IL_Def2, 4);       /* defaulting, with dest. field */
  655.                il->u[0].n = db_icntyp();      /* type code */
  656.                il->u[1].fld = db_ilvar();     /* source */
  657.                il->u[2].c_cd = db_ilc();      /* default value */
  658.                il->u[3].c_cd = db_ilc();      /* destination */
  659.                break;
  660.             default:
  661.                db_err1(1, "expected dflt1 or dflt2");
  662.             }
  663.          break;
  664.  
  665.       case 'r':
  666.          if (getc(db) != 'u' || getc(db) != 'n' || getc(db) != 'e' ||
  667.             getc(db) != 'r' || getc(db) != 'r')
  668.             db_err1(1, "expected runerr1 or runerr2");
  669.          switch (getc(db)) {
  670.             case '1':
  671.                il = new_il(IL_Err1, 1);       /* runerr, no offending value */
  672.                c = getc(db);
  673.                SkipWhSp(c)
  674.                GetInt(n, c)
  675.                il->u[0].n = n;                /* error number */
  676.                break;
  677.             case '2':
  678.                il = new_il(IL_Err2, 2);       /* runerr, with offending value */
  679.                c = getc(db);
  680.                SkipWhSp(c)
  681.                GetInt(n, c)
  682.                il->u[0].n = n;                /* error number */
  683.                il->u[1].fld = db_ilvar();     /* variable */
  684.                break;
  685.             default:
  686.                db_err1(1, "expected runerr1 or runerr2");
  687.             }
  688.          break;
  689.  
  690.       case 'i':
  691.          switch (getc(db)) {
  692.             case 'f':
  693.                switch (getc(db)) {
  694.                   case '1':
  695.                      il = new_il(IL_If1, 2);    /* if-then */
  696.                      il->u[0].fld = db_inlin(); /* condition */
  697.                      il->u[1].fld = db_inlin(); /* then clause */
  698.                      break;
  699.                   case '2':
  700.                      il = new_il(IL_If2, 3);     /* if-then-else */
  701.                      il->u[0].fld = db_inlin(); /* condition */
  702.                      il->u[1].fld = db_inlin(); /* then clause */
  703.                      il->u[2].fld = db_inlin(); /* else clause */
  704.                      break;
  705.                   default:
  706.                      db_err1(1, "expected if1 or if2");
  707.                   }
  708.                break;
  709.             case 's':
  710.                il = new_il(IL_Is, 2);         /* type check */
  711.                il->u[0].n = db_icntyp();      /* type code */
  712.                il->u[1].fld = db_ilvar();     /* variable */
  713.                break;
  714.             default:
  715.                db_err1(1, "expected if1, if2, or is");
  716.             }
  717.          break;
  718.  
  719.       case 'l':
  720.          switch (getc(db)) {
  721.             case 'c':
  722.                db_chstr("lc", "ase");
  723.                c = getc(db);
  724.                SkipWhSp(c)
  725.                GetInt(n, c)
  726.                il = new_il(IL_Lcase, 2 + 2 * n); /* length case */
  727.                il->u[0].n = n;                   /* number of cases */
  728.                indx = 1;
  729.                while (n--) {
  730.                   c = getc(db);
  731.                   SkipWhSp(c)
  732.                   GetInt(n1, c)
  733.                   il->u[indx++].n = n1;           /* selection number */
  734.                   il->u[indx++].fld = db_inlin(); /* action */
  735.                   }
  736.                il->u[indx].fld = db_inlin();      /* default */
  737.                break;
  738.  
  739.             case 's':
  740.                if (getc(db) != 't')
  741.                   db_err1(1, "expected lst");
  742.                il = new_il(IL_Lst, 2);            /* sequence of code parts */
  743.                il->u[0].fld = db_inlin();         /* 1st part */
  744.                il->u[1].fld = db_inlin();         /* 2nd part */
  745.                break;
  746.  
  747.             default:
  748.                db_err1(1, "expected lcase or lst");
  749.             }
  750.          break;
  751.  
  752.       case 'n':
  753.          db_chstr("n", "il");
  754.          il = NULL;
  755.          break;
  756.  
  757.       case 't': {
  758.          struct il_code *var;
  759.  
  760.          if (getc(db) != 'c' || getc(db) != 'a' || getc(db) != 's' ||
  761.             getc(db) != 'e')
  762.                db_err1(1, "expected tcase1 or tcase2");
  763.          switch (getc(db)) {
  764.             case '1':
  765.                var = db_ilvar();
  766.                c = getc(db);
  767.                SkipWhSp(c)
  768.                GetInt(n, c)
  769.                il = new_il(IL_Tcase1, 3 * n + 2); /* type case, no default */
  770.                il->u[0].fld = var;                /* variable */
  771.                db_case(il, n);                    /* get cases */
  772.                break;
  773.  
  774.             case '2':
  775.                var = db_ilvar();
  776.                c = getc(db);
  777.                SkipWhSp(c)
  778.                GetInt(n, c)
  779.                il = new_il(IL_Tcase2, 3 * n + 3);  /* type case, with default */
  780.                il->u[0].fld = var;                 /* variable */
  781.                db_case(il, n);                     /* get cases */
  782.                il->u[3 * n + 2].fld = db_inlin();  /* default */
  783.                break;
  784.  
  785.             default:
  786.                db_err1(1, "expected tcase1 or tcase2");
  787.             }
  788.          }
  789.          break;
  790.  
  791.       case '!':
  792.          il = new_il(IL_Bang, 1);                   /* negated condition */
  793.          il->u[0].fld = db_inlin();                 /* condition */
  794.          break;
  795.  
  796.       case '&':
  797.          if (getc(db) != '&')
  798.             db_err1(1, "expected &&");
  799.          il = new_il(IL_And, 2);                    /* && (conjunction) */
  800.          il->u[0].fld = db_inlin();                 /* 1st operand */
  801.          il->u[1].fld = db_inlin();                 /* 2nd operand */
  802.          break;
  803.  
  804.       default:
  805.          db_err1(1, "syntax error");
  806.       }
  807.    return il;
  808.    }
  809.  
  810. /*
  811.  * db_rtflg - get the sequence of 4 [or 5] flags that indicate whether code
  812.  *  for a operation [or body function] returns, fails, suspends, has error
  813.  *  failure, [or execution falls through the code].
  814.  */
  815. static int db_rtflg()
  816.    {
  817.    register int c;
  818.    int ret_flag;
  819.  
  820.    /*
  821.     * The presence of each flag is indicated by a unique character. Its absence
  822.     *  indicated by '_'.
  823.     */
  824.    ret_flag = 0;
  825.    c = getc(db);
  826.    SkipWhSp(c)
  827.    if (c == 'f')
  828.       ret_flag |= DoesFail;
  829.    else if (c != '_')
  830.      db_err1(1, "invalid return indicator");
  831.    c = getc(db);
  832.    if (c == 'r')
  833.       ret_flag |= DoesRet;
  834.    else if (c != '_')
  835.      db_err1(1, "invalid return indicator");
  836.    c = getc(db);
  837.    if (c == 's')
  838.       ret_flag |= DoesSusp;
  839.    else if (c != '_')
  840.      db_err1(1, "invalid return indicator");
  841.    c = getc(db);
  842.    if (c == 'e')
  843.       ret_flag |= DoesEFail;
  844.    else if (c != '_')
  845.      db_err1(1, "invalid return indicator");
  846.    c = getc(db);
  847.    if (c == 't')
  848.       ret_flag |= DoesFThru;
  849.    else if (c != '_' && c != ' ')
  850.      db_err1(1, "invalid return indicator");
  851.    return ret_flag;
  852.    }
  853.  
  854. /*
  855.  * db_case - get the cases for a type_case statement from the data base.
  856.  */
  857. static novalue db_case(il, num_cases)
  858. struct il_code *il;
  859. int num_cases;
  860.    {
  861.    register int c;
  862.    int *typ_vect;
  863.    int i, j;
  864.    int num_types;
  865.    int indx;
  866.  
  867.    il->u[1].n = num_cases;    /* number of cases */
  868.    indx = 2;
  869.    for (i = 0; i < num_cases; ++i) {
  870.       /*
  871.        * Determine the number of types in this case then store the
  872.        *  type codes in an array.
  873.        */
  874.       c = getc(db);
  875.       SkipWhSp(c)
  876.       GetInt(num_types, c)
  877.       il->u[indx++].n = num_types;
  878.       typ_vect = (int *)alloc((unsigned int)(sizeof(int) * num_types));
  879.       il->u[indx++].vect = typ_vect;
  880.       for (j = 0; j < num_types; ++j)
  881.          typ_vect[j] = db_icntyp();           /* type code */
  882.  
  883.       il->u[indx++].fld = db_inlin();         /* action */
  884.       }
  885.    }
  886.  
  887. /*
  888.  * db_ilvar - get a symbol table index for a simple variable or a
  889.  *  subscripted variable from the data base.
  890.  */
  891. static struct il_code *db_ilvar()
  892.    {
  893.    struct il_code *il;
  894.    register int c;
  895.    int n;
  896.  
  897.    c = getc(db);
  898.    SkipWhSp(c)
  899.  
  900.    if (isdigit(c)) {
  901.       /*
  902.        * Simple variable: just a symbol table index.
  903.        */
  904.       il = new_il(IL_Var, 1);
  905.       GetInt(n, c)
  906.       il->u[0].n = n;    /* symbol table index */
  907.       }
  908.    else {
  909.       if (c != '[')
  910.          db_err1(1, "expected symbol table index or '['");
  911.       /*
  912.        * Subscripted variable: symbol table index and subscript.
  913.        */
  914.       il = new_il(IL_Subscr, 2);
  915.       c = getc(db);
  916.       SkipWhSp(c);
  917.       GetInt(n, c)
  918.       il->u[0].n = n;    /* symbol table index */
  919.       c = getc(db);
  920.       SkipWhSp(c)
  921.       GetInt(n, c)
  922.       il->u[1].n = n;    /* subscripting index */
  923.       }
  924.    return il;
  925.    }
  926.  
  927. /*
  928.  * db_abstr - get abstract type computations from the data base.
  929.  */
  930. static struct il_code *db_abstr()
  931.    {
  932.    struct il_code *il;
  933.    register int c;
  934.    word typcd;
  935.    word indx;
  936.    int n;
  937.    int nargs;
  938.  
  939.    c = getc(db);
  940.    SkipWhSp(c)
  941.    switch (c) {
  942.       case 'l':
  943.          db_chstr("l", "st");
  944.          il = new_il(IL_Lst, 2);        /* sequence of code parts */
  945.          il->u[0].fld = db_abstr();     /* 1st part */
  946.          il->u[1].fld = db_abstr();     /* 2nd part */
  947.          break;
  948.  
  949.       case 'n':
  950.          switch (getc(db)) {
  951.             case 'e':
  952.                if (getc(db) != 'w')
  953.                   db_err1(1, "expected new");
  954.                typcd = db_icntyp();
  955.                c = getc(db);
  956.                SkipWhSp(c)
  957.                GetInt(nargs, c)
  958.                il = new_il(IL_New, 2 + nargs);  /* new structure create here */
  959.                il->u[0].n = typcd;              /* type code */
  960.                il->u[1].n = nargs;              /* number of args */
  961.                indx = 2;
  962.                while (nargs--)
  963.                   il->u[indx++].fld = db_abstr(); /* argument for component */
  964.                break;
  965.             case 'i':
  966.                if (getc(db) != 'l')
  967.                   db_err1(1, "expected nil");
  968.                il = NULL;
  969.                break;
  970.             default:
  971.                db_err1(1, "expected new or nil");
  972.             }
  973.        break;
  974.  
  975.       case 's':
  976.          db_chstr("s", "tore");
  977.          il = new_il(IL_Store, 1);  /* abstract store */
  978.          il->u[0].fld = db_abstr(); /* type to "dereference" */
  979.          break;
  980.  
  981.       case 't':
  982.          db_chstr("t", "yp");
  983.          il = new_il(IL_IcnTyp, 1);  /* explicit type */
  984.          il->u[0].n = db_icntyp();   /* type code */
  985.          break;
  986.  
  987.       case 'v':
  988.          db_chstr("v", "artyp");
  989.          il = new_il(IL_VarTyp, 1);        /* variable */
  990.          il->u[0].fld = db_ilvar();        /* symbol table index, etc */
  991.          break;
  992.       
  993.       case '.':
  994.          il = new_il(IL_Compnt, 2);        /* component access */
  995.          il->u[0].fld = db_abstr();        /* type being accessed */
  996.          c = getc(db);
  997.          SkipWhSp(c)
  998.          switch (c) {
  999.             case 'f':
  1000.                il->u[1].n = CM_Fields;
  1001.                break;
  1002.             case 'C':
  1003.                c = getc(db);
  1004.                GetInt(n, c)
  1005.                il->u[1].n = compnt_map[n];
  1006.                break;
  1007.             default:
  1008.                db_err1(1, "expected component code");
  1009.             }
  1010.          break;
  1011.  
  1012.       case '=':
  1013.          il = new_il(IL_TpAsgn, 2);        /* assignment (side effect) */
  1014.          il->u[0].fld = db_abstr();        /* left-hand-side */
  1015.          il->u[1].fld = db_abstr();        /* right-hand-side */
  1016.          break;
  1017.  
  1018.       case '+':
  1019.          if (getc(db) != '+')
  1020.             db_err1(1, "expected ++");
  1021.          il = new_il(IL_Union, 2);         /* ++ (union) */
  1022.          il->u[0].fld = db_abstr();        /* 1st operand */
  1023.          il->u[1].fld = db_abstr();        /* 2nd operand */
  1024.          break;
  1025.  
  1026.       case '*':
  1027.          if (getc(db) != '*')
  1028.             db_err1(1, "expected **"); 
  1029.          il = new_il(IL_Inter, 2);         /* ** (intersection) */
  1030.          il->u[0].fld = db_abstr();        /* 1st operand */
  1031.          il->u[1].fld = db_abstr();        /* 2nd operand */
  1032.          break;
  1033.       }
  1034.    return il;
  1035.    }
  1036.  
  1037. /*
  1038.  * db_ilc - read a piece of in-line C code.
  1039.  */
  1040. static struct il_c *db_ilc()
  1041.    {
  1042.    register int c;
  1043.    int old_c;
  1044.    word n;
  1045.    struct il_c *base = NULL;
  1046.    struct il_c **nxtp = &base;
  1047.  
  1048.    c = getc(db);
  1049.    SkipWhSp(c)
  1050.    switch (c) {
  1051.       case '$':
  1052.          /*
  1053.           * This had better be the starting $c.
  1054.           */
  1055.          c = getc(db);
  1056.          if (c == 'c') {
  1057.             c = getc(db);
  1058.             for (;;) {
  1059.                SkipWhSp(c)
  1060.                if (c == '$') {
  1061.                   c = getc(db);
  1062.                   switch (c) {
  1063.                      case 'c':             /* $cb or $cgoto <cond> <lbl num> */
  1064.                         c = getc(db);
  1065.                         switch (c) {
  1066.                            case 'b':
  1067.                               *nxtp = new_ilc(ILC_CBuf);
  1068.                               c = getc(db);
  1069.                               break;
  1070.                            case 'g':
  1071.                               db_chstr("$cg", "oto");
  1072.                               *nxtp = new_ilc(ILC_CGto);
  1073.                               (*nxtp)->code[0] = db_ilc();
  1074.                               c = getc(db);
  1075.                               SkipWhSp(c);
  1076.                               if (!isdigit(c))
  1077.                                  db_err1(1, "$cgoto: expected label number");
  1078.                               GetInt(n, c);
  1079.                               (*nxtp)->n = n;
  1080.                               break;
  1081.                            default:
  1082.                              db_err1(1, "expected $cb or $cgoto");
  1083.                            }
  1084.                         break;
  1085.                      case 'e':
  1086.                         c = getc(db);
  1087.                         if (c == 'f') {             /* $efail */
  1088.                             db_chstr("$ef", "ail");
  1089.                             *nxtp = new_ilc(ILC_EFail);
  1090.                             c = getc(db);
  1091.                             break;
  1092.                             }
  1093.                         else 
  1094.                            return base;            /* $e */
  1095.                      case 'f':                     /* $fail */
  1096.                         db_chstr("$f", "ail");
  1097.                         *nxtp = new_ilc(ILC_Fail);
  1098.                         c = getc(db);
  1099.                         break;
  1100.                      case 'g':                     /* $goto <lbl num> */
  1101.                         db_chstr("$g", "oto");
  1102.                         *nxtp = new_ilc(ILC_Goto);
  1103.                         c = getc(db);
  1104.                         SkipWhSp(c);
  1105.                         if (!isdigit(c))
  1106.                            db_err1(1, "$goto: expected label number");
  1107.                         GetInt(n, c);
  1108.                         (*nxtp)->n = n;
  1109.                         break;
  1110.                      case 'l':                     /* $lbl <lbl num> */
  1111.                         db_chstr("$l", "bl");
  1112.                         *nxtp = new_ilc(ILC_Lbl);
  1113.                         c = getc(db);
  1114.                         SkipWhSp(c);
  1115.                         if (!isdigit(c))
  1116.                            db_err1(1, "$lbl: expected label number");
  1117.                         GetInt(n, c);
  1118.                         (*nxtp)->n = n;
  1119.                         break;
  1120.                      case 'm':                     /* $m[d]<indx> */
  1121.                         *nxtp = new_ilc(ILC_Mod);
  1122.                         c = getc(db);
  1123.                         if (c == 'd') {
  1124.                            (*nxtp)->s = "d";
  1125.                            c = getc(db);
  1126.                            }
  1127.                         if (isdigit(c)) {
  1128.                            GetInt(n, c);
  1129.                            (*nxtp)->n = n;
  1130.                            }
  1131.                         else if (c == 'r') {
  1132.                            (*nxtp)->n = RsltIndx;
  1133.                            c = getc(db);
  1134.                            }
  1135.                         else
  1136.                            db_err1(1, "$m: expected symbol table index");
  1137.                         break;
  1138.                      case 'r':                     /* $r[d]<indx> or $ret ... */
  1139.                         c = getc(db);
  1140.                         if (isdigit(c) || c == 'd') {
  1141.                            *nxtp = new_ilc(ILC_Ref);
  1142.                            if (c == 'd') {
  1143.                               (*nxtp)->s = "d";
  1144.                               c = getc(db);
  1145.                               }
  1146.                            GetInt(n, c);
  1147.                            (*nxtp)->n = n;
  1148.                            }
  1149.                         else if (c == 'r') {
  1150.                            *nxtp = new_ilc(ILC_Ref);
  1151.                            (*nxtp)->n = RsltIndx;
  1152.                            c = getc(db);
  1153.                            }
  1154.                         else {
  1155.                            if (c != 'e' || getc(db) != 't')
  1156.                               db_err1(1, "expected $ret");
  1157.                            *nxtp = db_ilcret(ILC_Ret);
  1158.                            c = getc(db);
  1159.                            }
  1160.                         break;
  1161.                      case 's':                     /* $sb or $susp ... */
  1162.                         c = getc(db);
  1163.                         switch (c) {
  1164.                            case 'b':
  1165.                               *nxtp = new_ilc(ILC_SBuf);
  1166.                               c = getc(db);
  1167.                               break;
  1168.                            case 'u':
  1169.                               db_chstr("$su", "sp");
  1170.                               *nxtp = db_ilcret(ILC_Susp);
  1171.                               c = getc(db);
  1172.                               break;
  1173.                            default:
  1174.                              db_err1(1, "expected $sb or $susp");
  1175.                            }
  1176.                         break;
  1177.                      case 't':                     /* $t[d]<indx> */
  1178.                         *nxtp = new_ilc(ILC_Tend);
  1179.                         c = getc(db);
  1180.                         if (!isdigit(c))
  1181.                            db_err1(1, "$t: expected index");
  1182.                         GetInt(n, c);
  1183.                         (*nxtp)->n = n;
  1184.                         break;
  1185.                      case '{':
  1186.                         *nxtp = new_ilc(ILC_LBrc);
  1187.                         c = getc(db);
  1188.                         break;
  1189.                      case '}':
  1190.                         *nxtp = new_ilc(ILC_RBrc);
  1191.                         c = getc(db);
  1192.                         break;
  1193.                      default:
  1194.                         db_err1(1, "invalid $ escape in C code");
  1195.                      }
  1196.                   }
  1197.                else {
  1198.                   /*
  1199.                    * Arbitrary code - gather into a string.
  1200.                    */
  1201.                   while (c != '$') {
  1202.                      if (c == '"' || c == '\'') {
  1203.                         quoted(c);
  1204.                         c = getc(db);
  1205.                         }
  1206.                      if (c == '\n')
  1207.                         ++dbline;
  1208.                      if (c == EOF)
  1209.                         db_err1(1, "unexpected EOF in C code");
  1210.                      old_c = c;
  1211.                      AppChar(db_sbuf, c);
  1212.                      c = getc(db);
  1213.                      if (old_c == ' ')
  1214.                         while (c == ' ')
  1215.                            c = getc(db);
  1216.                      }
  1217.                   *nxtp = new_ilc(ILC_Str);
  1218.                   (*nxtp)->s = str_install(&db_sbuf);
  1219.                   }
  1220.                nxtp = &(*nxtp)->next;
  1221.                }
  1222.             }
  1223.          break;
  1224.       case 'n':
  1225.          db_chstr("n", "il");
  1226.          return NULL;
  1227.       }
  1228.    db_err1(1, "expected C code of the form $c ... $e or nil");
  1229.    }
  1230.  
  1231. /*
  1232.  * quoted - get the string for a quoted literal. The first quote mark
  1233.  *  has been read.
  1234.  */
  1235. static novalue quoted(delim)
  1236. int delim;
  1237.    {
  1238.    register int c;
  1239.  
  1240.    AppChar(db_sbuf, delim);
  1241.    c = getc(db);
  1242.    while (c != delim && c != EOF) {
  1243.       if (c == '\\') {
  1244.          AppChar(db_sbuf, c);
  1245.          c = getc(db);
  1246.          if (c == EOF)
  1247.             db_err1(1, "unexpected EOF in quoted literal");
  1248.          }
  1249.       AppChar(db_sbuf, c);
  1250.       c = getc(db);
  1251.       }
  1252.    if (c == EOF)
  1253.       db_err1(1, "unexpected EOF in quoted literal");
  1254.    AppChar(db_sbuf, c);
  1255.    }
  1256.  
  1257. /*
  1258.  * db_ilcret - get the in-line C code on a return or suspend statement.
  1259.  */
  1260. static struct il_c *db_ilcret(il_c_type)
  1261. int il_c_type;
  1262.    {
  1263.    struct il_c *ilc;
  1264.    int c;
  1265.    int n;
  1266.    int i;
  1267.  
  1268.    ilc = new_ilc(il_c_type);
  1269.    ilc->n = db_icntyp();       /* kind of return expression */
  1270.    c = getc(db);
  1271.    SkipWhSp(c)
  1272.    GetInt(n, c)                /* number of arguments in this expression */
  1273.    for (i = 0; i < n; ++i)
  1274.       ilc->code[i] = db_ilc(); /* an argument to the return expression */
  1275.    return ilc;
  1276.    } 
  1277.  
  1278. /*
  1279.  * db_tndtyp - get the indication for the type of a tended declaration.
  1280.  */
  1281. static int db_tndtyp()
  1282.    {
  1283.    int c;
  1284.  
  1285.    c = getc(db);
  1286.    SkipWhSp(c)
  1287.    switch (c) {
  1288.        case 'b':
  1289.           db_chstr("b", "lkptr");
  1290.           return TndBlk;          /* tended block pointer */
  1291.        case 'd':
  1292.           db_chstr("d", "esc");
  1293.           return TndDesc;         /* tended descriptor */
  1294.        case 's':
  1295.           db_chstr("s", "tr");
  1296.           return TndStr;          /* tended string */
  1297.       default:
  1298.           db_err1(1, "expected blkptr, desc, or str");
  1299.           /* NOTREACHED */
  1300.       }
  1301.    }
  1302.  
  1303. /*
  1304.  * db_icntyp - get a type code from the data base.
  1305.  */
  1306. static int db_icntyp()
  1307.    {
  1308.    int c;
  1309.    int n;
  1310.  
  1311.    c = getc(db);
  1312.    SkipWhSp(c)
  1313.    switch (c) {
  1314.       case 'T':
  1315.          c = getc(db);
  1316.          GetInt(n, c)
  1317.          if (n < num_typs)
  1318.             return type_map[n];       /* type code from specification system */
  1319.          break;
  1320.       case 'a':
  1321.          return TypAny;               /* a - any type */
  1322.       case 'c':
  1323.          switch (getc(db)) {
  1324.             case 'i':
  1325.                return TypCInt;        /* ci - C integer */
  1326.             case 'd': 
  1327.                return TypCDbl;        /* cd - C double */
  1328.             case 's':
  1329.                return TypCStr;        /* cs - C string */
  1330.             }
  1331.          break;
  1332.       case 'd':
  1333.          return RetDesc;              /* d - descriptor on return statement */
  1334.       case 'e':
  1335.          switch (getc(db)) {
  1336.             case 'c':
  1337.                if (getc(db) == 'i')
  1338.                   return TypECInt;    /* eci - exact C integer */
  1339.                break;
  1340.             case 'i':
  1341.                return TypEInt;        /* ei - exact integer */
  1342.             case ' ':
  1343.             case '\n':
  1344.             case '\t':
  1345.                 return TypEmpty;      /* e - empty  type */
  1346.             }
  1347.          break;
  1348.       case 'n':
  1349.          if (getc(db) == 'v')
  1350.             return RetNVar;           /* nv - named variable on return */
  1351.          break;
  1352.       case 'r':
  1353.          if (getc(db) == 'n')
  1354.             return RetNone;           /* rn - nothing explicitly returned */
  1355.          break;
  1356.       case 's':
  1357.          if (getc(db) == 'v')
  1358.             return RetSVar;           /* sv - structure variable on return */
  1359.          break;
  1360.       case 't':
  1361.          switch (getc(db)) {
  1362.             case 'c':
  1363.                return TypTCset;       /* tc - temporary cset */
  1364.             case 's':
  1365.                return TypTStr;        /* ts - temporary string */
  1366.             }
  1367.          break;
  1368.       case 'v':
  1369.          return TypVar;               /* v - variable */
  1370.       }
  1371.    db_err1(1, "invalid type code");
  1372.    /* NOTREACHED */
  1373.    }
  1374.  
  1375. /*
  1376.  * new_ilc - allocate a new structure to hold a piece of in-line C code.
  1377.  */
  1378. static struct il_c *new_ilc(il_c_type)
  1379. int il_c_type;
  1380.    {
  1381.    struct il_c *ilc;
  1382.    int i;
  1383.  
  1384.    ilc = NewStruct(il_c);
  1385.    ilc->next = NULL;
  1386.    ilc->il_c_type = il_c_type;
  1387.    for (i = 0; i < 3; ++i)
  1388.       ilc->code[i] = NULL;
  1389.    ilc->n = 0;
  1390.    ilc->s = NULL;
  1391.    return ilc;
  1392.    }
  1393.  
  1394. /*
  1395.  * new_il - allocate a new structure with "size" fields to hold a piece of
  1396.  *   RTL code.
  1397.  */
  1398. struct il_code *new_il(il_type, size)
  1399. int il_type;
  1400. int size;
  1401.    {
  1402.    struct il_code *il;
  1403.  
  1404.    il = (struct il_code *)alloc((unsigned int)
  1405.       (sizeof(struct il_code) + (size-1) * sizeof(union il_fld)));
  1406.    il->il_type = il_type;
  1407.    return il;
  1408.    }
  1409.  
  1410. /*
  1411.  * db_dscrd - discard an implementation up to $end, skipping the in-line
  1412.  *   RTL code.
  1413.  */
  1414. novalue db_dscrd(ip)
  1415. struct implement *ip;
  1416.    {
  1417.    char state;  /* how far along we are at recognizing $end */
  1418.  
  1419.    free(ip);
  1420.    state = '\0';
  1421.    for (;;) {
  1422.       switch (getc(db)) {
  1423.          case '$':
  1424.             state = '$';
  1425.             continue;
  1426.          case 'e':
  1427.             if (state == '$') {
  1428.                state = 'e';
  1429.                continue;
  1430.                }
  1431.             break;
  1432.          case 'n':
  1433.             if (state == 'e') {
  1434.                state = 'n';
  1435.                continue;
  1436.                }
  1437.             break;
  1438.          case 'd':
  1439.             if (state == 'n')
  1440.                return;
  1441.             break;
  1442.          case '\n':
  1443.             ++dbline;
  1444.             break;
  1445.          case EOF:
  1446.             db_err1(1, "unexpected EOF");
  1447.          }
  1448.       state = '\0';
  1449.       }
  1450.    }
  1451.  
  1452. /*
  1453.  * db_chstr - we are expecting a specific string. We may already have
  1454.  *   read a prefix of it.
  1455.  */
  1456. novalue db_chstr(prefix, suffix)
  1457. char *prefix;
  1458. char *suffix;
  1459.    {
  1460.    int c;
  1461.  
  1462.    c = getc(db);
  1463.    SkipWhSp(c)
  1464.  
  1465.    for (;;) {
  1466.       if (*suffix == '\0' && (isspace(c) || c == EOF)) {
  1467.          if (c == '\n')
  1468.             ++dbline;
  1469.          return;
  1470.          }
  1471.       else if (*suffix != c)
  1472.          break;
  1473.       c = getc(db);
  1474.       ++suffix;
  1475.       }
  1476.    db_err3(1, "expected:", prefix, suffix);
  1477.    }
  1478.  
  1479. /*
  1480.  * db_tbl - fill in a hash table of implementation information for the
  1481.  *  given section.
  1482.  */
  1483. int db_tbl(section, tbl)
  1484. char *section;
  1485. struct implement **tbl;
  1486.    {
  1487.    struct implement *ip;
  1488.    int num_added = 0;
  1489.    unsigned hashval;
  1490.  
  1491.    /*
  1492.     * Get past the section header.
  1493.     */
  1494.    db_chstr("", section);
  1495.  
  1496.    /*
  1497.     * Create an entry in the hash table for each entry in the data base.
  1498.     *  If multiple data bases are loaded into one hash table, use the
  1499.     *  first entry encountered for each operation.
  1500.     */
  1501.    while ((ip = db_impl(toupper(section[0]))) != NULL) {
  1502.       if (db_ilkup(ip->name, tbl) == NULL) {
  1503.          db_code(ip);
  1504.          hashval = IHasher(ip->name);
  1505.          ip->blink = tbl[hashval];
  1506.          tbl[hashval] = ip;
  1507.          ++num_added;
  1508.          db_chstr("", "end");
  1509.          }
  1510.       else
  1511.          db_dscrd(ip);
  1512.       }
  1513.    db_chstr("", "endsect");
  1514.    return num_added;
  1515.    }
  1516.  
  1517. /*
  1518.  * db_ilkup - look up id in a table of implementation information and return
  1519.  *  pointer it or NULL if it is not there.
  1520.  */
  1521. struct implement *db_ilkup(id, tbl)
  1522. char *id;
  1523. struct implement **tbl;
  1524.    {
  1525.    register struct implement *ptr;
  1526.  
  1527.    ptr = tbl[IHasher(id)];
  1528.    while (ptr != NULL && ptr->name != id)
  1529.       ptr = ptr->blink;
  1530.    return ptr;
  1531.    }
  1532.  
  1533. /*
  1534.  * nxt_pre - assign next prefix. A prefix consists of n characters each from
  1535.  *   the range 0-9 and a-z, at least one of which is a digit.
  1536.  *
  1537.  */
  1538. novalue nxt_pre(pre, nxt, n)
  1539. char *pre;
  1540. char *nxt;
  1541. int n;
  1542.    {
  1543.    int i, num_dig;
  1544.  
  1545.    if (nxt[0] == '\0') {
  1546.       fprintf(stderr, "out of unique prefixes\n");
  1547.       exit(ErrorExit);
  1548.       }
  1549.  
  1550.    /*
  1551.     * copy the next prefix into the output string.
  1552.     */
  1553.    for (i = 0; i < n; ++i)
  1554.       pre[i] = nxt[i];
  1555.  
  1556.    /*
  1557.     * Increment next prefix. First, determine how many digits there are in
  1558.     *  the current prefix.
  1559.     */
  1560.    num_dig = 0;
  1561.    for (i = 0; i < n; ++i)
  1562.       if (isdigit(nxt[i]))
  1563.          ++num_dig;
  1564.  
  1565.    for (i = n - 1; i >= 0; --i) {
  1566.       switch (nxt[i]) {
  1567.          case '9':
  1568.             /*
  1569.              * If there is at least one other digit, increment to a letter.
  1570.              *  Otherwise, start over at zero and continue to the previous
  1571.              *  character in the prefix.
  1572.              */
  1573.             if (num_dig > 1) {
  1574.                nxt[i] = 'a';
  1575.                return;
  1576.                }
  1577.             else
  1578.                nxt[i] = '0';
  1579.             break;
  1580.  
  1581. #if EBCDIC
  1582.          case 'i':
  1583.             nxt[i] = 'j';
  1584.             return;
  1585.          case 'r':
  1586.             nxt[i] = 's';
  1587.             return;
  1588. #endif                    /* EBCDIC */
  1589.  
  1590.          case 'z':
  1591.             /*
  1592.              * Start over at zero and continue to previous character in the
  1593.              *  prefix.
  1594.              */
  1595.             nxt[i] = '0';
  1596.             ++num_dig;
  1597.             break;
  1598.          default:
  1599.             ++nxt[i];
  1600.             return;
  1601.          }
  1602.       }
  1603.  
  1604.    /*
  1605.     * Indicate that there are no more prefixes.
  1606.     */
  1607.    nxt[0] = '\0';
  1608.    }
  1609.  
  1610. /*
  1611.  * cmp_pre - lexically compare 2-character prefixes.
  1612.  */
  1613. int cmp_pre(pre1, pre2)
  1614. char *pre1;
  1615. char *pre2;
  1616.    {
  1617.    int cmp;
  1618.  
  1619.    cmp = cmp_1_pre(pre1[0], pre2[0]);
  1620.    if (cmp == 0)
  1621.       return cmp_1_pre(pre1[1], pre2[1]);
  1622.    else
  1623.       return cmp;
  1624.    }
  1625.  
  1626. /*
  1627.  * cmp_1_pre - lexically compare 1 character of a prefix.
  1628.  */
  1629. static int cmp_1_pre(p1, p2)
  1630. int p1;
  1631. int p2;
  1632.    {
  1633.    if (isdigit(p1)) {
  1634.       if (isdigit(p2))
  1635.          return p1 - p2;
  1636.       else
  1637.          return -1;
  1638.       }
  1639.     else {
  1640.        if (isdigit(p2))
  1641.           return 1;
  1642.        else
  1643.          return p1 - p2;
  1644.       }
  1645.    }
  1646.  
  1647. /*
  1648.  * db_err1 - print a data base error message in the form of 1 string.
  1649.  */
  1650. novalue db_err1(fatal, s)
  1651. int fatal;
  1652. char *s;
  1653.    {
  1654.    if (fatal)
  1655.       fprintf(stderr, "error, ");
  1656.    else
  1657.       fprintf(stderr, "warning, ");
  1658.    fprintf(stderr, "data base \"%s\", line %d - %s\n", dbname, dbline, s);
  1659.    if (fatal)
  1660.       exit(ErrorExit);
  1661.    }
  1662.  
  1663. /*
  1664.  * db_err2 - print a data base error message in the form of 2 strings.
  1665.  */
  1666. novalue db_err2(fatal, s1, s2)
  1667. int fatal;
  1668. char *s1;
  1669. char *s2;
  1670.    {
  1671.    if (fatal)
  1672.       fprintf(stderr, "error, ");
  1673.    else
  1674.       fprintf(stderr, "warning, ");
  1675.    fprintf(stderr, "data base \"%s\", line %d - %s %s\n", dbname, dbline, s1,
  1676.       s2);
  1677.    if (fatal)
  1678.       exit(ErrorExit);
  1679.    }
  1680.  
  1681. /*
  1682.  * db_err3 - print a data base error message in the form of 3 strings.
  1683.  */
  1684. static novalue db_err3(fatal, s1, s2, s3)
  1685. int fatal;
  1686. char *s1;
  1687. char *s2;
  1688. char *s3;
  1689.    {
  1690.    if (fatal)
  1691.       fprintf(stderr, "error, ");
  1692.    else
  1693.       fprintf(stderr, "warning, ");
  1694.    fprintf(stderr, "data base \"%s\", line %d - %s %s%s\n", dbname, dbline, s1,
  1695.       s2, s3);
  1696.    if (fatal)
  1697.       exit(ErrorExit);
  1698.    }
  1699.